home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / w3 / socks.el.z / socks.el
Encoding:
Text File  |  1998-05-21  |  13.2 KB  |  391 lines
  1. ;;; socks.el --- A Socks v5 Client for Emacs
  2. ;; Author: wmperry
  3. ;; Created: 1997/12/24 16:47:40
  4. ;; Version: 1.7
  5. ;; Keywords: comm, firewalls
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;; Copyright (c) 1996, 1997 by William M. Perry <wmperry@cs.indiana.edu>
  9. ;;;
  10. ;;; This file is not part of GNU Emacs, but the same permissions apply.
  11. ;;;
  12. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  13. ;;; it under the terms of the GNU General Public License as published by
  14. ;;; the Free Software Foundation; either version 2, or (at your option)
  15. ;;; any later version.
  16. ;;;
  17. ;;; GNU Emacs is distributed in the hope that it will be useful,
  18. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20. ;;; GNU General Public License for more details.
  21. ;;;
  22. ;;; You should have received a copy of the GNU General Public License
  23. ;;; along with GNU Emacs; see the file COPYING.  If not, write to
  24. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  25. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26. ;;;
  27. ;;; This is an implementation of the SOCKS v5 protocol as defined in
  28. ;;; RFC 1928.
  29. ;;;
  30. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  31. (require 'cl)
  32.  
  33. (defconst socks-version 5)
  34. (defvar socks-debug nil)
  35.  
  36. ;; Common socks v5 commands
  37. (defconst socks-connect-command 1)
  38. (defconst socks-bind-command 2)
  39. (defconst socks-udp-associate-command 3)
  40.  
  41. ;; Miscellaneous other socks constants
  42. (defconst socks-authentication-null 0)
  43. (defconst socks-authentication-failure 255)
  44.  
  45. ;; Response codes
  46. (defconst socks-response-success               0)
  47. (defconst socks-response-general-failure       1)
  48. (defconst socks-response-access-denied         2)
  49. (defconst socks-response-network-unreachable   3)
  50. (defconst socks-response-host-unreachable      4)
  51. (defconst socks-response-connection-refused    5)
  52. (defconst socks-response-ttl-expired           6)
  53. (defconst socks-response-cmd-not-supported     7)
  54. (defconst socks-response-address-not-supported 8)
  55.  
  56. (defvar socks-errors
  57.   '("Succeeded"
  58.     "General SOCKS server failure"
  59.     "Connection not allowed by ruleset"
  60.     "Network unreachable"
  61.     "Host unreachable"
  62.     "Connection refused"
  63.     "Time-to-live expired"
  64.     "Command not supported"
  65.     "Address type not supported"))
  66.  
  67. ;; The socks v5 address types
  68. (defconst socks-address-type-v4   1)
  69. (defconst socks-address-type-name 3)
  70. (defconst socks-address-type-v6   4)
  71.  
  72. ;; Base variables
  73. (defvar socks-host (or (getenv "SOCKS5_SERVER") "socks"))
  74. (defvar socks-port (or (getenv "SOCKS5_PORT")   1080))
  75. (defvar socks-timeout 5)
  76. (defvar socks-connections (make-hash-table :size 13))
  77.  
  78. ;; Miscellaneous stuff for authentication
  79. (defvar socks-authentication-methods nil)
  80. (defvar socks-username (user-login-name))
  81. (defvar socks-password nil)
  82.  
  83. (defun socks-register-authentication-method (id desc callback)
  84.   (let ((old (assq id socks-authentication-methods)))
  85.     (if old
  86.     (setcdr old (cons desc callback))
  87.       (setq socks-authentication-methods
  88.         (cons (cons id (cons desc callback))
  89.           socks-authentication-methods)))))
  90.  
  91. (defun socks-unregister-authentication-method (id)
  92.   (let ((old (assq id socks-authentication-methods)))
  93.     (if old
  94.     (setq socks-authentication-methods
  95.           (delq old socks-authentication-methods)))))
  96.  
  97. (socks-register-authentication-method 0 "No authentication" 'identity)
  98.  
  99. (defun socks-build-auth-list ()
  100.   (let ((num 0)
  101.     (retval ""))
  102.     (mapcar
  103.      (function
  104.       (lambda (x)
  105.     (if (fboundp (cdr (cdr x)))
  106.         (setq retval (format "%s%c" retval (car x))
  107.           num (1+ num)))))
  108.      socks-authentication-methods)
  109.     (format "%c%s" num retval)))
  110.  
  111. (defconst socks-state-waiting-for-auth 0)
  112. (defconst socks-state-submethod-negotiation 1)
  113. (defconst socks-state-authenticated 2)
  114. (defconst socks-state-waiting 3)
  115. (defconst socks-state-connected 4)
  116.  
  117. (defmacro socks-wait-for-state-change (proc htable cur-state)
  118.   (`
  119.    (while (and (= (cl-gethash 'state (, htable)) (, cur-state))
  120.            (memq (process-status (, proc)) '(run open)))
  121.      (accept-process-output (, proc) socks-timeout))))
  122.  
  123. (defun socks-filter (proc string)
  124.   (let ((info (cl-gethash proc socks-connections))
  125.     state desired-len)
  126.     (or info (error "socks-filter called on non-SOCKS connection %S" proc))
  127.     (setq state (cl-gethash 'state info))
  128.     (cond
  129.      ((= state socks-state-waiting-for-auth)
  130.       (cl-puthash 'scratch (concat string (cl-gethash 'scratch info)) info)
  131.       (setq string (cl-gethash 'scratch info))
  132.       (if (< (length string) 2)
  133.       nil                ; We need to spin some more
  134.     (cl-puthash 'authtype (aref string 1) info)
  135.     (cl-puthash 'scratch (substring string 2 nil) info)
  136.     (cl-puthash 'state socks-state-submethod-negotiation info)))
  137.      ((= state socks-state-submethod-negotiation)
  138.       )
  139.      ((= state socks-state-authenticated)
  140.       )
  141.      ((= state socks-state-waiting)
  142.       (cl-puthash 'scratch (concat string (cl-gethash 'scratch info)) info)
  143.       (setq string (cl-gethash 'scratch info))
  144.       (if (< (length string) 4)
  145.       nil
  146.     (setq desired-len
  147.           (+ 6            ; Standard socks header
  148.          (cond
  149.           ((= (aref string 3) socks-address-type-v4) 4)
  150.           ((= (aref string 3) socks-address-type-v6) 16)
  151.           ((= (aref string 3) socks-address-type-name)
  152.            (if (< (length string) 5)
  153.                255
  154.              (+ 1 (aref string 4)))))))
  155.     (if (< (length string) desired-len)
  156.         nil                ; Need to spin some more
  157.       (cl-puthash 'state socks-state-connected info)
  158.       (cl-puthash 'reply (aref string 1) info)
  159.       (cl-puthash 'response string info))))
  160.      ((= state socks-state-connected)
  161.       )
  162.      )
  163.     )
  164.   )
  165.  
  166. (defun socks-open-connection (&optional host port)
  167.   (interactive)
  168.   (setq host (or host socks-host)
  169.     port (or port socks-port))
  170.   (save-excursion
  171.     (let ((proc (socks-original-open-network-stream "socks"
  172.                             nil
  173.                             host port))
  174.       (info (make-hash-table :size 13))
  175.       (authtype nil))
  176.  
  177.       ;; Initialize process and info about the process
  178.       (set-process-filter proc 'socks-filter)
  179.       (process-kill-without-query proc)
  180.       (cl-puthash proc info socks-connections)
  181.       (cl-puthash 'state socks-state-waiting-for-auth info)
  182.       (cl-puthash 'authtype socks-authentication-failure info)
  183.  
  184.       ;; Send what we think we can handle for authentication types
  185.       (process-send-string proc (format "%c%s" socks-version
  186.                     (socks-build-auth-list)))
  187.  
  188.       ;; Basically just do a select() until we change states.
  189.       (socks-wait-for-state-change proc info socks-state-waiting-for-auth)
  190.       (setq authtype (cl-gethash 'authtype info))
  191.       (cond
  192.        ((= authtype socks-authentication-null)
  193.     (and socks-debug (message "No authentication necessary")))
  194.        ((= authtype socks-authentication-failure)
  195.     (error "No acceptable authentication methods found."))
  196.        (t
  197.     (let* ((auth-type (char-int (cl-gethash 'authtype info)))
  198.            (auth-handler (assoc auth-type socks-authentication-methods))
  199.            (auth-func (and auth-handler (cdr (cdr auth-handler))))
  200.            (auth-desc (and auth-handler (car (cdr auth-handler)))))
  201.       (set-process-filter proc nil)
  202.       (if (and auth-func (fboundp auth-func)
  203.            (funcall auth-func proc))
  204.           nil            ; We succeeded!
  205.         (delete-process proc)
  206.         (error "Failed to use auth method: %s (%d)"
  207.            (or auth-desc "Unknown") auth-type))
  208.       )
  209.     )
  210.        )
  211.       (cl-puthash 'state socks-state-authenticated info)
  212.       (set-process-filter proc 'socks-filter)
  213.       proc)))
  214.  
  215. (defun socks-send-command (proc command atype address port)
  216.   (let ((addr (case atype
  217.         (socks-address-type-v4 address)
  218.         (socks-address-type-v6 address)
  219.         (t
  220.          (format "%c%s" (length address) address))))
  221.     (info (cl-gethash proc socks-connections)))
  222.     (or info (error "socks-send-command called on non-SOCKS connection %S"
  223.             proc))
  224.     (cl-puthash 'state socks-state-waiting info)
  225.     (process-send-string proc
  226.              (format 
  227.               "%c%c%c%c%s%c%c"
  228.               socks-version    ; version 
  229.               command    ; command
  230.               0        ; reserved
  231.               atype        ; address type
  232.               addr        ; address
  233.               (lsh port -8)    ; port, high byte
  234.               (- port (lsh (lsh port -8) 8)) ; port, low byte
  235.               ))
  236.     (socks-wait-for-state-change proc info socks-state-waiting)
  237.     (if (= (cl-gethash 'reply info) socks-response-success)
  238.     nil                ; Sweet sweet success!
  239.       (delete-process proc)
  240.       (error "%s" (nth (cl-gethash 'reply info) socks-errors)))
  241.     proc))
  242.  
  243.  
  244. ;; Replacement functions for open-network-stream, etc.
  245. (defvar socks-noproxy nil
  246.   "*List of regexps matching hosts that we should not socksify connections to")
  247.  
  248. (defun socks-find-route (host service)
  249.   (let ((route (cons socks-host socks-port))
  250.     (noproxy socks-noproxy))
  251.     (while noproxy
  252.       (if (eq ?! (aref (car noproxy) 0))
  253.       (if (string-match (substring (car noproxy) 1) host)
  254.           (setq route nil
  255.             noproxy nil))
  256.     (if (string-match (car noproxy) host)
  257.         (setq route nil
  258.           noproxy nil)))
  259.       (setq noproxy (cdr noproxy)))
  260.     route))
  261.  
  262. (defvar socks-override-functions nil
  263.   "*Whether to overwrite the open-network-stream function with the SOCKSified
  264. version.")
  265.  
  266. (if (fboundp 'socks-original-open-network-stream)
  267.     nil                    ; Do nothing, we've been here already
  268.   (fset 'socks-original-open-network-stream
  269.     (symbol-function 'open-network-stream))
  270.   (if socks-override-functions
  271.       (fset 'open-network-stream 'socks-open-network-stream)))
  272.  
  273. (defvar socks-services-file "/etc/services")
  274. (defvar socks-tcp-services (make-hash-table :size 13 :test 'equal))
  275. (defvar socks-udp-services (make-hash-table :size 13 :test 'equal))
  276.  
  277. (defun socks-parse-services ()
  278.   (if (not (and (file-exists-p socks-services-file)
  279.         (file-readable-p socks-services-file)))
  280.       (error "Could not find services file: %s" socks-services-file))
  281.   (save-excursion
  282.     (clrhash socks-tcp-services)
  283.     (clrhash socks-udp-services)
  284.     (set-buffer (get-buffer-create " *socks-tmp*"))
  285.     (erase-buffer)
  286.     (insert-file-contents socks-services-file)
  287.     ;; Nuke comments
  288.     (goto-char (point-min))
  289.     (while (re-search-forward "#.*" nil t)
  290.       (replace-match ""))
  291.     ;; Nuke empty lines
  292.     (goto-char (point-min))
  293.     (while (re-search-forward "^[ \t\n]+" nil t)
  294.       (replace-match ""))
  295.     ;; Now find all the lines
  296.     (goto-char (point-min))
  297.     (let (name port type)
  298.       (while (re-search-forward "^\\([^ \t]+\\)[ \t]+\\([0-9]+\\)/\\([a-z]+\\)"
  299.                 nil t)
  300.     (setq name (downcase (match-string 1))
  301.           port (string-to-int (match-string 2))
  302.           type (downcase (match-string 3)))
  303.     (cl-puthash name port (if (equal type "udp")
  304.                    socks-udp-services
  305.                  socks-tcp-services))))))
  306.  
  307. (defun socks-find-services-entry (service &optional udp)
  308.   "Return the port # associated with SERVICE"
  309.   (if (= (hash-table-count socks-tcp-services) 0)
  310.       (socks-parse-services))
  311.   (cl-gethash (downcase service)
  312.           (if udp socks-udp-services socks-tcp-services)))
  313.  
  314. (defun socks-open-network-stream (name buffer host service)
  315.   (let* ((route (socks-find-route host service))
  316.      proc info)
  317.     (if (not route)
  318.     (socks-original-open-network-stream name buffer host service)
  319.       (setq proc (socks-open-connection (car route) (cdr route))
  320.         info (cl-gethash proc socks-connections))
  321.       (socks-send-command proc socks-connect-command
  322.               socks-address-type-name
  323.               host
  324.               (if (stringp service)
  325.                   (socks-find-services-entry service)
  326.                 service))
  327.       (cl-puthash 'buffer buffer info)
  328.       (cl-puthash 'host host info)
  329.       (cl-puthash 'service host info)
  330.       (set-process-filter proc nil)
  331.       (set-process-buffer proc (if buffer (get-buffer-create buffer)))
  332.       proc)))
  333.  
  334. ;; Authentication modules go here
  335.  
  336. ;; Basic username/password authentication, ala RFC 1929
  337. (socks-register-authentication-method 2 "Username/Password"
  338.                       'socks-username/password-auth)
  339.  
  340. (defconst socks-username/password-auth-version 1)
  341.  
  342. (if (not (fboundp 'char-int))
  343.     (fset 'char-int 'identity))
  344.  
  345. (defun socks-username/password-auth-filter (proc str)
  346.   (let ((info (cl-gethash proc socks-connections))
  347.     state desired-len)
  348.     (or info (error "socks-filter called on non-SOCKS connection %S" proc))
  349.     (setq state (cl-gethash 'state info))
  350.     (cl-puthash 'scratch (concat (cl-gethash 'scratch info) str) info)
  351.     (if (< (length (cl-gethash 'scratch info)) 2)
  352.     nil
  353.       (cl-puthash 'password-auth-status (char-int
  354.                      (aref (cl-gethash 'scratch info) 1))
  355.           info)
  356.       (cl-puthash 'state socks-state-authenticated info))))
  357.  
  358. (defun socks-username/password-auth (proc)
  359.   (if (not socks-password)
  360.       (setq socks-password (read-passwd
  361.                 (format "Password for %s@%s: "
  362.                     socks-username socks-host))))
  363.   (let* ((info (cl-gethash proc socks-connections))
  364.      (state (cl-gethash 'state info)))
  365.     (cl-puthash 'scratch "" info)
  366.     (set-process-filter proc 'socks-username/password-auth-filter)
  367.     (process-send-string proc
  368.              (format "%c%c%s%c%s"
  369.                  socks-username/password-auth-version
  370.                  (length socks-username)
  371.                  socks-username
  372.                  (length socks-password)
  373.                  socks-password))
  374.     (socks-wait-for-state-change proc info state)
  375.     (= (cl-gethash 'password-auth-status info) 0)))
  376.  
  377.  
  378. ;; More advanced GSS/API stuff, not yet implemented - volunteers?
  379. ;; (socks-register-authentication-method 1 "GSS/API" 'socks-gssapi-auth)
  380.  
  381. (defun socks-gssapi-auth (proc)
  382.   nil)
  383.  
  384.  
  385. ;; CHAP stuff
  386. ;; (socks-register-authentication-method 3 "CHAP" 'socks-chap-auth)
  387. (defun socks-chap-auth (proc)
  388.   nil)
  389.  
  390. (provide 'socks)
  391.